home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _dc31ffa23fe41fa38c12420ad092c366 < prev    next >
Encoding:
Text File  |  2002-05-30  |  5.7 KB  |  207 lines

  1.  
  2. package Plot;
  3.  
  4. # Class "Plot": constructor, methods, destructor, global class data,
  5. # etcetera.
  6. #
  7. # Because a Plot object is a composite widget all the Composite base
  8. # class methods and advertised widgets are available to you.
  9. #
  10. # Advertised Plot widgets:  canvas, entry, PostScript_button, view_button.
  11.  
  12. require 5.002;
  13.  
  14. use vars qw/$VERSION @ISA/;
  15. $VERSION = '3.013'; # $Id: //depot/Tk8/demos/demos/widget_lib/Plot.pm#13 $
  16.  
  17. use Tk::Frame;
  18. use base  qw(Tk::Frame);
  19. Construct Tk::Widget 'Plot';
  20. use strict;
  21.  
  22. # Plot Virtual Methods
  23. #     $plot = $MW->Plot(
  24. #           -title_color        => 'Brown',
  25. #           -inactive_highlight => 'Skyblue2',
  26. #           -active_highlight   => 'red',
  27. #       );
  28.  
  29. sub Populate {
  30.  
  31.     # Plot composite widget constructor.
  32.  
  33.     my($cw, $args) = @_;
  34.  
  35.     $cw->SUPER::Populate($args);
  36.     my($tc, $ih, $ah) = (
  37.     delete $args->{-title_color},
  38.     delete $args->{-inactive_highlight},
  39.     delete $args->{-active_highlight},
  40.     );
  41.  
  42.     my %pinfo;            # plot information hash
  43.     $pinfo{'lastX'} = 0;
  44.     $pinfo{'lastY'} = 0;
  45.     $pinfo{'areaX2'} = -1;
  46.     $pinfo{'prcmd'} = 'lpr';
  47.  
  48.     my $plot_font = '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*';
  49.  
  50.     my $c = $cw->Canvas(
  51.         -relief => 'raised', 
  52.         -width  => '450', 
  53.         -height => '300',
  54.         -cursor => 'top_left_arrow',
  55.     );
  56.     $cw->Advertise('canvas' => $c);
  57.     $c->pack(-side => 'top', -fill => 'x');
  58.  
  59.     $c->createLine(100, 250, 400, 250, -width => 2);
  60.     $c->createLine(100, 250, 100, 50, -width => 2);
  61.     $c->createText(225, 20, -text => 'A Simple Plot', -font => $plot_font,
  62.            -fill => $tc);
  63.     
  64.     my($i, $x, $y, $point, $item);
  65.     for($i = 0; $i <= 10; $i++) {
  66.     $x = 100 + ($i * 30);
  67.     $c->createLine($x, 250, $x, 245, -width => 2);
  68.     $c->createText($x, 254, -text => 10 * $i, -anchor => 'n',
  69.            -font => $plot_font);
  70.     } # forend
  71.     for ($i = 0; $i <= 5; $i++) {
  72.     $y =  250 - ($i * 40);
  73.     $c->createLine(100, $y, 105, $y, -width => 2);
  74.     $c->createText(96, $y, -text => $i * 50.0, -anchor => 'e',
  75.            -font => $plot_font);
  76.     } # forend
  77.     
  78.     foreach $point ([12, 56], [20, 94], [33, 98], [32, 120], [61, 180],
  79.             [75, 160], [98, 223]) {
  80.     $x = 100 + (3 * ${$point}[0]);
  81.         $y = 250 - (4 * ${$point}[1]) / 5;
  82.         $item = $c->createOval($x-6, $y-6, $x+6, $y+6, -width => 1,
  83.                -outline => 'black', -fill => $ih);
  84.         $c->addtag('point', 'withtag', $item);
  85.     }
  86.  
  87.     $c->bind('point', '<Any-Enter>' => [sub{shift->itemconfigure(@_)},
  88.                     'current', -fill => $ah]);
  89.     $c->bind('point', '<Any-Leave>' => [sub{shift->itemconfigure(@_)},
  90.                     'current', -fill => $ih]);
  91.     $c->bind('point', '<1>' => [sub {plot_down(@_)}, \%pinfo]);
  92.     $c->bind('point', '<ButtonRelease-1>' => sub {shift->dtag('selected')});
  93.     $c->CanvasBind('<B1-Motion>' => [sub {plot_move(@_)}, \%pinfo]);
  94.     $c->CanvasBind('<2>' => [sub {area_down(@_)}, \%pinfo]);
  95.     $c->CanvasBind('<B2-Motion>' => [sub {area_move(@_)}, \%pinfo]);
  96.  
  97.     my $w_prcmd = $cw->Entry(
  98.         -textvariable => \$pinfo{'prcmd'},
  99.     );
  100.     $cw->Advertise('entry' => $w_prcmd);
  101.     $w_prcmd->pack;
  102.  
  103.     my $w_print = $cw->Button(
  104.         -text         => 'Print in PostScript Format',
  105.         -command      => [\&area_save, $c, \%pinfo],
  106.     );
  107.     $cw->Advertise('PostScript_button' => $w_print);
  108.     $w_print->pack;
  109.     $w_prcmd->bind('<Return>' => [$w_print => 'invoke']);
  110.  
  111.     my $w_view = $cw->Button(
  112.         -text    => 'View Composite Plot Widget',
  113.         -command => [\&::view_widget_code,
  114.                  Tk->findINC('demos/widget_lib/Plot.pm'),
  115.                     ],
  116.     );
  117.     $cw->Advertise('view_button' => $w_view);
  118.     $w_view->pack;
  119.  
  120.     return $cw;
  121.  
  122. } # end Populate, Plot constructor
  123.  
  124. # Private methods.
  125.  
  126. sub area_down {
  127.  
  128.     my($w, $pinfo) = @_;
  129.  
  130.     my $e = $w->XEvent;
  131.     my($x, $y) = ($e->x, $e->y);
  132.     $pinfo->{'areaX1'} = $x;
  133.     $pinfo->{'areaY1'} = $y;
  134.     $pinfo->{'areaX2'} = -1;
  135.     $pinfo->{'areaY2'} = -1;
  136.     eval {local $SIG{'__DIE__'}; $w->delete('area');};
  137.  
  138. } # end area_down
  139.  
  140. sub area_move {
  141.  
  142.     my($w, $pinfo) = @_;
  143.  
  144.     my $e = $w->XEvent;
  145.     my($x, $y) = ($e->x, $e->y);
  146.     if($x != $pinfo->{'areaX1'} && $y != $pinfo->{'areaY1'}) {
  147.       eval {local $SIG{'__DIE__'}; $w->delete('area');};
  148.       $w->addtag('area','withtag',$w->createRectangle($pinfo->{'areaX1'},
  149.                                            $pinfo->{'areaY1'},$x,$y));
  150.       $pinfo->{'areaX2'} = $x;
  151.       $pinfo->{'areaY2'} = $y;
  152.     }
  153. } # end area_move
  154.  
  155. sub area_save {
  156.     
  157.     my($w, $pinfo) = @_;
  158.     
  159.     my($x1, $x2, $y1, $y2, $a);
  160.     
  161.     if($pinfo->{'areaX2'} != -1) {
  162.     ($x1, $x2, $y1, $y2) = 
  163.       @$pinfo{'areaX1', 'areaX2', 'areaY1', 'areaY2'}; # slice !
  164.     ($x1, $x2) = @$pinfo{'areaX2', 'areaX1'} if $x2 <= $x1;
  165.     ($y1, $y2) = @$pinfo{'areaY2', 'areaY1'} if $y2 <= $y1;
  166.     $a = $w->postscript('-x' => $x1, '-y' => $y1,
  167.                 -width => $x2 - $x1, -height => $y2 - $y1);
  168.     } else {
  169.     $a = $w->postscript;
  170.     }
  171.     
  172.     $SIG{'PIPE'} = sub {};
  173.     open(LPR, "| $pinfo->{'prcmd'}");
  174.     print LPR $a;
  175.     close(LPR);
  176.  
  177. } # end area_save
  178.  
  179. sub plot_down {
  180.  
  181.     my($w, $pinfo) = @_;
  182.  
  183.     my $e = $w->XEvent;
  184.     my($x, $y) = ($e->x, $e->y);
  185.     $w->dtag('selected');
  186.     $w->addtag('selected', 'withtag', 'current');
  187.     $w->raise('current');
  188.     $pinfo->{'lastX'} = $x;
  189.     $pinfo->{'lastY'} = $y;
  190.  
  191. } # end plot_down
  192.  
  193. sub plot_move {
  194.  
  195.     my($w, $pinfo) = @_;
  196.  
  197.     my $e = $w->XEvent;
  198.     my($x, $y) = ($e->x, $e->y);
  199.     $w->move('selected',  $x-$pinfo->{'lastX'}, $y-$pinfo->{'lastY'});
  200.     $pinfo->{'lastX'} = $x;
  201.     $pinfo->{'lastY'} = $y;
  202.  
  203. } # end plot_move
  204.  
  205. 1;
  206.